home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr16.lha / lap.lisp < prev    next >
Lisp/Scheme  |  1992-07-24  |  16KB  |  501 lines
  1. ;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; This file defines PCL's interface to the LAP mechanism.
  32. ;;;
  33. ;;; The file is divided into two parts.  The first part defines the interface
  34. ;;; used by PCL to create abstract LAP code vectors.  PCL never creates lists
  35. ;;; that represent LAP code directly, it always calls this mechanism to do so.
  36. ;;; This provides a layer of error checking on the LAP code before it gets to
  37. ;;; the implementation-specific assembler.  Note that this error checking is
  38. ;;; syntactic only, but even so is useful to have.  Because of it, no specific
  39. ;;; LAP assembler should worry itself with checking the syntax of the LAP code.
  40. ;;;
  41. ;;; The second part of the file defines the LAP assemblers for each PCL port.
  42. ;;; These are included together in the same file to make it easier to change
  43. ;;; them all should some random change be made in the LAP mechanism.
  44. ;;;
  45.  
  46. (defvar *make-lap-closure-generator*)
  47. (defvar *precompile-lap-closure-generator*)
  48. (defvar *lap-in-lisp*)
  49.  
  50. (defun make-lap-closure-generator 
  51.     (closure-variables arguments iregs vregs fvregs tregs lap-code)
  52.   (funcall *make-lap-closure-generator*
  53.        closure-variables arguments iregs 
  54.        vregs fvregs tregs lap-code))
  55.  
  56. (defmacro precompile-lap-closure-generator 
  57.     (cvars args i-regs v-regs fv-regs t-regs lap)
  58.   (funcall *precompile-lap-closure-generator* cvars args i-regs 
  59.        v-regs fv-regs t-regs lap))
  60.  
  61. (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
  62.   (declare (ignore cvars args))
  63.   `(locally (declare #.*optimize-speed*)
  64.      ,(make-lap-prog iregs vregs fvregs tregs
  65.              (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))))
  66.  
  67.  
  68. ;;;
  69. ;;; The following functions and macros are used by PCL when generating LAP
  70. ;;; code:
  71. ;;;
  72. ;;;  GENERATING-LAP
  73. ;;;  WITH-LAP-REGISTERS
  74. ;;;  ALLOCATE-REGISTER
  75. ;;;  DEALLOCATE-REGISTER
  76. ;;;  LAP-FLATTEN
  77. ;;;  OPCODE
  78. ;;;  OPERAND
  79. ;;; 
  80. (proclaim '(special *generating-lap*))        ;CAR   - alist of free registers
  81.                         ;CADR  - alist of allocated registers
  82.                         ;CADDR - max reg number allocated
  83.                         ;
  84.                         ;in each alist, the entries have
  85.                         ;the form:  (type . (:REG <n>))
  86.                         ;
  87.  
  88. ;;;
  89. ;;; This goes around the generation of any lap code.  <body> should return a lap
  90. ;;; code sequence, this macro will take care of converting that to a lap closure
  91. ;;; generator.
  92. ;;; 
  93. (defmacro generating-lap (closure-variables arguments &body body)
  94.   `(let* ((*generating-lap* (list () () -1)))
  95.      (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
  96.  
  97. (defmacro generating-lap-in-lisp (closure-variables arguments &body body)
  98.   `(let* ((*generating-lap* (list () () -1)))
  99.      (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
  100.  
  101. ;;;
  102. ;;; Each register specification looks like:
  103. ;;;
  104. ;;;  (<var> <type> &key :reuse <other-reg>)
  105. ;;;  
  106. (defmacro with-lap-registers (register-specifications &body body)
  107.   ;;
  108.   ;; Given that, for now, there is only one keyword argument and
  109.   ;; that, for now, we do no error checking, we can be pretty
  110.   ;; sleazy about how this works.
  111.   ;;
  112.   (flet ((make-allocations ()
  113.        (gathering1 (collecting)
  114.          (dolist (spec register-specifications)
  115.            (gather1
  116.          `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec))))))))
  117.      (make-deallocations ()
  118.        (gathering1 (collecting)
  119.          (dolist (spec register-specifications)
  120.            (gather1
  121.          `(unless ,(cadddr spec) (deallocate-register ,(car spec))))))))
  122.     `(let ,(make-allocations)
  123.        (multiple-value-prog1 (progn ,@body)
  124.                  ,@(make-deallocations)))))
  125.  
  126. (defun allocate-register (type)
  127.   (destructuring-bind (free allocated) *generating-lap*
  128.     (let ((entry (assoc type free)))
  129.       (cond (entry
  130.          (setf (car *generating-lap*)  (delete entry free)
  131.            (cadr *generating-lap*) (cons entry allocated))
  132.          (cdr entry))
  133.         (t
  134.          (let ((new `(,type . (:reg ,(incf (caddr *generating-lap*))))))
  135.            (setf (cadr *generating-lap*) (cons new allocated))
  136.            (cdr new)))))))
  137.  
  138. (defun deallocate-register (reg)
  139.   (let ((entry (rassoc reg (cadr *generating-lap*))))
  140.     (unless entry (error "Attempt to free an unallocated register."))
  141.     (push entry (car *generating-lap*))
  142.     (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*)))))
  143.  
  144. (defvar *precompiling-lap* nil)
  145.  
  146. (defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
  147.   (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized."))
  148.   (let ((iregs ())
  149.     (vregs ())
  150.     (fvregs ())
  151.     (tregs ()))
  152.     (dolist (entry (car *generating-lap*))
  153.       (ecase (car entry)
  154.     (index  (push (caddr entry) iregs))
  155.     (vector (push (caddr entry) vregs))
  156.     (fixnum-vector (push (caddr entry) fvregs))
  157.     ((t)    (push (caddr entry) tregs))))
  158.     (cond (in-lisp-p
  159.        `(lap-in-lisp ,closure-variables ,arguments ,iregs 
  160.                      ,vregs ,fvregs ,tregs ,lap-code))
  161.       (*precompiling-lap*
  162.        `(precompile-lap-closure-generator 
  163.          ,closure-variables ,arguments ,iregs
  164.          ,vregs ,fvregs ,tregs ,lap))
  165.       (t
  166.        (make-lap-closure-generator
  167.          closure-variables arguments iregs 
  168.          vregs fvregs tregs lap-code)))))
  169.  
  170. (defun flatten-lap (&rest opcodes-or-sequences)
  171.   (let ((result ()))
  172.     (dolist (opcode-or-sequence opcodes-or-sequences result)
  173.       (cond ((null opcode-or-sequence))
  174.             ((not (consp (car opcode-or-sequence)))     ;its an opcode
  175.              (setf result (append result (list opcode-or-sequence))))
  176.             (t
  177.              (setf result (append result opcode-or-sequence)))))))
  178.  
  179. (defmacro flattening-lap ()
  180.   '(let ((result ()))
  181.     (values #'(lambda (value) (push value result))
  182.      #'(lambda () (apply #'flatten-lap (reverse result))))))
  183.  
  184.  
  185.  
  186. ;;;
  187. ;;; This code deals with the syntax of the individual opcodes and operands.
  188. ;;; 
  189.   
  190. ;;;
  191. ;;; The first two of these variables are documented to all ports.  They are
  192. ;;; lists of the symbols which name the lap opcodes and operands.  They can
  193. ;;; be useful to determine whether a port has implemented all the required
  194. ;;; opcodes and operands.
  195. ;;;
  196. ;;; The third of these variables is for use of the emitter only.
  197. ;;; 
  198. (defvar *lap-operands* ())
  199. (defvar *lap-opcodes*  ())
  200. (defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
  201.  
  202. (defun opcode (name &rest args)
  203.   (let ((emitter (gethash name *lap-emitters*)))
  204.     (if emitter
  205.     (apply emitter args)
  206.     (error "No opcode named ~S." name))))
  207.  
  208. (defun operand (name &rest args)
  209.   (let ((emitter (gethash name *lap-emitters*)))
  210.     (if emitter
  211.     (apply emitter args)
  212.     (error "No operand named ~S." name))))
  213.  
  214. (defmacro defopcode (name types)
  215.   (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*))
  216.     (lambda-list
  217.       (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
  218.     `(progn
  219.        (eval-when (load eval) (load-defopcode ',name ',fn-name))
  220.        (defun ,fn-name ,lambda-list
  221.      #+Genera (declare (sys:function-parent ,name defopcode))
  222.      (defopcode-1 ',name ',types ,@lambda-list)))))
  223.  
  224. (defmacro defoperand (name types)
  225.   (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-package*))
  226.     (lambda-list
  227.       (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
  228.     `(progn
  229.        (eval-when (load eval) (load-defoperand ',name ',fn-name))
  230.        (defun ,fn-name ,lambda-list
  231.      #+Genera (declare (sys:function-parent ,name defoperand))
  232.      (defoperand-1 ',name ',types ,@lambda-list)))))
  233.  
  234. (defun load-defopcode (name fn-name)
  235.   (if* (memq name *lap-operands*)
  236.        (error "LAP opcodes and operands must have disjoint names.")
  237.        (setf (gethash name *lap-emitters*) fn-name)
  238.        (pushnew name *lap-opcodes*)))
  239.  
  240. (defun load-defoperand (name fn-name)
  241.   (if* (memq name *lap-opcodes*)
  242.        (error "LAP opcodes and operands must have disjoint names.")
  243.        (setf (gethash name *lap-emitters*) fn-name)
  244.        (pushnew name *lap-operands*)))
  245.  
  246. (defun defopcode-1 (name operand-types &rest args)
  247.   (iterate ((arg (list-elements args))
  248.         (type (list-elements operand-types)))
  249.     (check-opcode-arg name arg type))
  250.   (cons name (copy-list args)))
  251.  
  252. (defun defoperand-1 (name operand-types &rest args)
  253.   (iterate ((arg (list-elements args))
  254.         (type (list-elements operand-types)))
  255.     (check-operand-arg name arg type))
  256.   (cons name (copy-list args)))
  257.  
  258. (defun check-opcode-arg (name arg type)
  259.   (labels ((usual (x)
  260.          (and (consp arg) (eq (car arg) x)))
  261.        (check (x)
  262.          (ecase x           
  263.            ((:reg :cdr :constant :iref :instance-ref :cvar :arg :lisp :lisp-variable)
  264.         (usual x))
  265.            (:label (symbolp arg))
  266.            (:operand (and (consp arg) (memq (car arg) *lap-operands*))))))
  267.     (unless (if (consp type)
  268.         (if (eq (car type) 'or)
  269.             (some #'check (cdr type))
  270.             (error "What type is this?"))
  271.         (check type))
  272.       (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
  273.  
  274. (defun check-operand-arg (name arg type)  
  275.   (flet ((check (x)
  276.        (ecase x
  277.          (:symbol           (symbolp arg))
  278.          (:register-number  (and (integerp arg) (>= arg 0)))
  279.          (:t                t)
  280.          (:reg              (and (consp arg) (eq (car arg) :reg)))
  281.          (:fixnum           (typep arg 'fixnum)))))
  282.     (unless (if (consp type)
  283.         (if (eq (car type) 'or)
  284.             (some #'check (cdr type))
  285.             (error "What type is this?"))
  286.         (check type))
  287.       (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
  288.  
  289.  
  290.  
  291. ;;;
  292. ;;; The actual opcodes.
  293. ;;;
  294. (defopcode :break ())                ;For debugging only.  Not
  295. (defopcode :beep  ())                ;all ports are required to
  296. (defopcode :print (:reg))            ;implement this.
  297.  
  298.  
  299. (defopcode :move (:operand (or :reg :iref :instance-ref :cdr :lisp-variable)))
  300.  
  301. (defopcode :eq     ((or :reg :constant) (or :reg :constant) :label))
  302. (defopcode :neq    ((or :reg :constant) (or :reg :constant) :label))
  303. (defopcode :fix=   ((or :reg :constant) (or :reg :constant) :label))
  304. (defopcode :izerop (:reg :label))
  305.  
  306. (defopcode :std-instance-p       (:reg :label))
  307. (defopcode :fsc-instance-p       (:reg :label))
  308. (defopcode :built-in-instance-p  (:reg :label))
  309. (defopcode :structure-instance-p (:reg :label))
  310.  
  311. (defopcode :jmp      ((or :reg :constant)))
  312. (defopcode :emf-call ((or :reg :constant)))
  313.  
  314. (defopcode :label  (:label))
  315. (defopcode :go     (:label))
  316.  
  317. (defopcode :return ((or :reg :constant)))
  318.  
  319. (defopcode :exit-lap-in-lisp ())
  320.  
  321. ;;;
  322. ;;; The actual operands.
  323. ;;;
  324. (defoperand :reg  (:register-number))
  325. (defoperand :cvar (:symbol))
  326. (defoperand :arg  (:symbol))
  327.  
  328. (defoperand :cdr  (:reg))
  329.  
  330. (defoperand :constant (:t))
  331.  
  332. (defoperand :std-wrapper       (:reg))
  333. (defoperand :fsc-wrapper       (:reg))
  334. (defoperand :built-in-wrapper  (:reg))
  335. (defoperand :structure-wrapper (:reg))
  336. (defoperand :other-wrapper     (:reg))
  337. (defoperand :built-in-or-structure-wrapper (:reg))
  338.  
  339. (defoperand :std-slots (:reg))
  340. (defoperand :fsc-slots (:reg))
  341.  
  342. (defoperand :wrapper-cache-number-vector (:reg))
  343.  
  344. (defoperand :cref (:reg :fixnum))
  345.  
  346. (defoperand :iref (:reg :reg))
  347. (defoperand :iset (:reg :reg :reg))
  348.  
  349. (defoperand :instance-ref (:reg :reg))
  350. (defoperand :instance-set (:reg :reg :reg))
  351.  
  352. (defoperand :i1+     (:reg))
  353. (defoperand :i+      (:reg :reg))
  354. (defoperand :i-      (:reg :reg))
  355. (defoperand :ilogand (:reg :reg))
  356. (defoperand :ilogxor (:reg :reg))
  357. (defoperand :ishift  (:reg :fixnum))
  358.  
  359. (defoperand :lisp (:t))
  360. (defoperand :lisp-variable (:symbol))
  361.  
  362.  
  363.  
  364. ;;;
  365. ;;; LAP tests (there need to be a lot more of these)
  366. ;;;
  367. #|
  368. (defun make-lap-test-closure-1 (result)
  369.   #'(lambda (arg1)
  370.       (declare (pcl-fast-call))
  371.       (declare (ignore arg1))
  372.       result))
  373.  
  374. (defun make-lap-test-closure-2 (result)
  375.   #'(lambda (arg1 arg2)
  376.       (declare (pcl-fast-call))
  377.       (declare (ignore arg1 arg2))
  378.       result))
  379.  
  380. (eval-when (eval)
  381.   (compile 'make-lap-test-closure-1)
  382.   (compile 'make-lap-test-closure-2))
  383.  
  384. (proclaim '(special lap-win lap-lose))
  385. (eval-when (load eval)
  386.   (setq lap-win (make-lap-test-closure-1 'win)
  387.     lap-lose (make-lap-test-closure-1 'lose)))
  388.  
  389. (defun lap-test-1 ()
  390.   (let* ((cg (generating-lap '(cache)
  391.                  '(arg)
  392.            (with-lap-registers ((i0 index)
  393.                     (v0 vector)
  394.                     (t0 t))
  395.          (flatten-lap 
  396.            (opcode :move (operand :cvar 'cache) v0)
  397.            (opcode :move (operand :arg 'arg) i0)
  398.            (opcode :move (operand :iref v0 i0) t0)
  399.            (opcode :jmp t0)))))
  400.      
  401.      (cache (make-array 32))
  402.      (closure (funcall cg cache))
  403.      (fn0 (make-lap-test-closure-1 'fn0))
  404.      (fn1 (make-lap-test-closure-1 'fn1))
  405.      (fn2 (make-lap-test-closure-1 'fn2))
  406.      (in0 (index-value->index 2))
  407.      (in1 (index-value->index 10))
  408.      (in2 (index-value->index 27)))
  409.     
  410.     (setf (svref cache (index->index-value in0)) fn0
  411.       (svref cache (index->index-value in1)) fn1
  412.       (svref cache (index->index-value in2)) fn2)
  413.     
  414.     (unless (and (eq (funcall closure in0) 'fn0)
  415.          (eq (funcall closure in1) 'fn1)
  416.          (eq (funcall closure in2) 'fn2))
  417.       (error "LAP TEST 1 failed."))))
  418.  
  419. (defun lap-test-2 ()            
  420.   (let* ((cg (generating-lap '(cache mask) 
  421.                  '(arg)
  422.            (with-lap-registers ((i0 index)
  423.                     (i1 index)
  424.                     (i2 index)
  425.                     (v0 vector)
  426.                     (t0 t))
  427.  
  428.          (flatten-lap          
  429.            (opcode :move (operand :cvar 'cache) v0)
  430.            (opcode :move (operand :arg 'arg) i0)
  431.            (opcode :move (operand :cvar 'mask) i1)
  432.            (opcode :move (operand :ilogand i0 i1) i2)
  433.            (opcode :move (operand :iref v0 i2) t0)
  434.            (opcode :jmp t0)))))
  435.      (cache (make-array 32))
  436.      (mask #b00110)
  437.      (closure (funcall cg cache mask))
  438.      (in0 (index-value->index #b00010))
  439.      (in1 (index-value->index #b01010))
  440.      (in2 (index-value->index #b10011)))
  441.     (fill cache lap-lose)
  442.     (setf (svref cache (index->index-value in0)) lap-win)
  443.     
  444.     (unless (and (eq (funcall closure in0) 'win)
  445.          (eq (funcall closure in1) 'win)
  446.          (eq (funcall closure in2) 'win))
  447.       (error "LAP TEST 2 failed."))))
  448.  
  449. (defun lap-test-3 ()            
  450.   (let* ((cg (generating-lap '(addend) '(arg)
  451.            (with-lap-registers
  452.          ((i0 index)
  453.           (i1 index)
  454.           (i2 index))
  455.  
  456.          (flatten-lap          
  457.            (opcode :move (operand :cvar 'addend) i0)
  458.            (opcode :move (operand :arg 'arg) i1)
  459.            (opcode :move (operand :i+ i0 i1) i2)
  460.            (opcode :return i2)))))
  461.      (closure (funcall cg (index-value->index 5))))
  462.     
  463.     (unless (= (index->index-value (funcall closure (index-value->index 2))) 7)
  464.       (error "LAP TEST 3 failed."))))
  465.  
  466. (defun lap-test-4 ()            
  467.   (let* ((cg (generating-lap '(winner loser) '(arg)
  468.            (with-lap-registers ((t0 t))
  469.          (flatten-lap
  470.            (opcode :move (operand :arg 'arg) t0)
  471.            (opcode :eq t0 (operand :constant 'foo) 'win)
  472.            (opcode :move (operand :cvar 'loser) t0)
  473.            (opcode :jmp t0)
  474.            (opcode :label 'win)
  475.            (opcode :move (operand :cvar 'winner) t0)
  476.            (opcode :jmp t0)))))
  477.      (closure (funcall cg #'true #'false)))
  478.     (unless (and (eq (funcall closure 'foo) 't)
  479.          (eq (funcall closure 'bar) 'nil))
  480.       (error "LAP TEST 4 failed."))))
  481.  
  482. (defun lap-test-5 ()            
  483.   (let* ((cg (generating-lap '(array) '(arg)
  484.            (with-lap-registers ((r0 vector)
  485.                     (r1 t)
  486.                     (r2 index))
  487.          (flatten-lap
  488.            (opcode :move (operand :cvar 'array) r0)
  489.            (opcode :move (operand :arg 'arg) r1)
  490.            (opcode :move (operand :constant (index-value->index 0)) r2)
  491.            (opcode :move r1 (operand :iref r0 r2))
  492.            (opcode :return r1)))))
  493.      (array (make-array 1))
  494.      (closure (funcall cg array)))
  495.     (unless (and (=  (funcall closure 1)    (svref array 0))
  496.          (eq (funcall closure 'foo) (svref array 0)))
  497.       (error "LAP TEST 5 failed."))))
  498.  
  499. |#
  500.  
  501.